Attribute VB_Name = "FixPicture"
Option Explicit

Private Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
End Type

Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type

Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type

Private Const HORZRES = 8
Private Const VERTRES = 10

Private Const SRCCOPY = &HCC0020

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)




Private Sub main()

    Dim hdc As Long
    hdc = GetDC(0)

    Dim nWidth As Long, nHeight As Long
    nWidth = GetDeviceCaps(hdc, HORZRES)
    nHeight = GetDeviceCaps(hdc, VERTRES)

    Dim bmpInfo As BITMAPINFO
    bmpInfo.bmiHeader.biSize = 40
    bmpInfo.bmiHeader.biHeight = nHeight
    bmpInfo.bmiHeader.biWidth = nWidth
    bmpInfo.bmiHeader.biPlanes = 1
    bmpInfo.bmiHeader.biBitCount = 24

    Dim hDCMem As Long
    hDCMem = CreateCompatibleDC(hdc)

    Dim hBmp As Long
    Dim lpvoidvoid As Long
    hBmp = CreateDIBSection(hDCMem, bmpInfo, 0, lpvoidvoid, 0, 0)
    
    Dim hOldObj As Long
    hOldObj = SelectObject(hDCMem, hBmp)
    
    BitBlt hDCMem, 0, 0, nWidth, nHeight, hdc, 0, 0, SRCCOPY

    Dim imgSize As Long
    imgSize = nHeight * nWidth * 3

    Dim bytData() As Byte
    ReDim bytData(imgSize)

    CopyMemory bytData(0), ByVal lpvoidvoid, imgSize
    
    Dim bmpFileHeader As BITMAPFILEHEADER
    bmpFileHeader.bfType = &H4D42
    bmpFileHeader.bfOffBits = Len(bmpFileHeader) + Len(bmpInfo)
    bmpFileHeader.bfSize = bmpFileHeader.bfOffBits + imgSize
    
    Open Format(Timer, "000000") & ".BMP" For Binary As #1
    Put #1, , bmpFileHeader
    Put #1, , bmpInfo
    Put #1, , bytData
    Close

    DeleteObject hBmp
    DeleteDC hDCMem
    DeleteDC hdc
End Sub

